perm filename MPSUB.F4[MSS,LCS] blob
sn#356839 filedate 1978-05-19 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE STRTUP
C00010 ENDMK
Cā;
SUBROUTINE STRTUP
COMMON /NAM/NAM
TYPE 1
ACCEPT 2,K
IF(K.EQ.' ')K='TEST'
CALL IFILE(1,K)
3 TYPE 4
ACCEPT 2,NAM
IF(NAM.EQ.K)GO TO 3
C DON'T USE SAME NAME FOR IN AND OUT
IF(NAM.EQ.' ')NAM='NOTES'
CALL OFILE(21,NAM)
C DEFAULT NAM
1 FORMAT(' INPUT NAME = '$)
2 FORMAT(A5)
4 FORMAT(' OUTPUT NAME = '$)
END
SUBROUTINE ONEUP(L,J,N)
DIMENSION L(1)
J=J+1
L(J)=N
END
FUNCTION NUMS(N)
C FINDS ASCII NUMBER (NUMS=-1)
NUMS=0
IF(N.GE.'0'.AND.N.LE.'9')NUMS=-1
IF(N.EQ.'.')NUMS=-1
C DOT IS CONSIDERED PART OF A NUMBER
END
FUNCTION LETS(N)
C FINDS LETTER (LETS=-1)
LETS=0
IF(N.GE.'A'.AND.N.LE.'Z')LETS=-1
END
FUNCTION ISGN(J)
COMMON /INP/JN,I(1)
ISGN=JN+1
N=I(J+1)
IF(N.EQ.'+')GO TO 1
IF(N.NE.'-')RETURN
ISGN=-ISGN
GO TO 2
1 ISGN=ISGN+100
C FOR SLUR AND BEAM STEM REVERSAL
2 J=J+1
END
SUBROUTINE I2A(JN,MM,M,N)
COMMON/NUM/NUM(0/9)
DATA NUM/'0','1','2','3','4','5','6','7','8','9'/
K=JN
N=K/100
MM=NUM(N)
K=K-N*100
N=K/10
M=NUM(N)
N=NUM(K-N*10)
C CHANGES 2-DIGIT NUMBERS TO FROM INTEGER TO ASCII
END
SUBROUTINE A2I(J,N)
COMMON /INP/JN,I(1) /NUM/NUM(0/9)
L=N
N=0
3 DO 1 K=0,9
1 IF(L.EQ.NUM(K))GO TO 2
2 N=N*10+K
L=I(J+1)
IF(NUMS(L).EQ.0)RETURN
J=J+1
GO TO 3
END
SUBROUTINE UPDATE(N,K)
DIMENSION N(1)
COMMON /J/J,JJ /INP/JN,I(1)
DO 1 L=JJ,J
K=K+1
1 N(K)=I(L)
END
FUNCTION LETNUM(N)
COMMON /J/J,JJ /INP/JN,I(1)
1 /MKS/ MKS(11)
DATA MKS/'/',';','<','>',-19728949184,-18655207360,'(',')','.'
1,'-','*'/
C THE GIANT NUMBERS ARE FOR [ AND ]
1 IF(N.NE.' ')GO TO 2
N=ICHAR(J)
GO TO 1
2 IF(NUMS(N).EQ.0)GO TO 3
4 LETNUM=2
RETURN
3 IF(LETS(N).EQ.0)GO TO 40
CATCHES LETTERS AND MINUS SIGN (FOR INVIS. CLEFS)
7 LETNUM=1
RETURN
40 DO 5 K=1,11
5 IF(N.EQ.MKS(K))GO TO (6,6,9,9,10,10,11,11,4,7,8)K
CCCC CALL ERR(J)
6 LETNUM=3
C / ;
RETURN
8 LETNUM=8
C *
RETURN
9 LETNUM=4
C < >
RETURN
10 LETNUM=5
C [ ]]
RETURN
11 LETNUM=K-1
C ( )
END
SUBROUTINE OUTIT(I,K)
DIMENSION I(1)
IF(K.EQ.0)K=1
I(K)=';'
M=1
1 N=M+60
DO 2 L=N,M,-1
J=I(L)
2 IF(J.EQ.'/'.OR.J.EQ.';')GO TO 3
3 IF(L.GT.K)L=K
WRITE(21,10)(I(J),J=M,L)
TYPE 11,(I(J),J=M,L)
IF(L.EQ.K)RETURN
M=L+1
GO TO 1
10 FORMAT(70A1)
11 FORMAT(1X70A1)
END
SUBROUTINE UPCNT
COMMON /INP/JN,I(1) /J/J,JJ,JX
C GETS LAST NOTE NUM.
K=J
JR=0
1 K=K-1
N=I(K)
IF(NUMS(N))GO TO 1
CALL A2I(K,N)
IF(JR.NE.0)GO TO 4
IF(JX.EQ.-99)GO TO 2
JN=JN+N-1
RETURN
2 JR=N
3 K=K-1
IF(I(K).EQ.' ')GO TO 3
GO TO 1
4 JN=JN+JR*N-N-1
END
CC SUBROUTINE ERR(J)
CC COMMON /INP/JN,I(1)
CC TYPE 1,(I(K),K=1,J)
CC1 FORMAT(1X80A1,/' ****** ERROR *****')
CC STOP
CC END
SUBROUTINE READ(K)
COMMON /INP/JN,I(80)
10 FORMAT(80A1)
11 FORMAT(1X80A1)
1 READ(1,10,END=2)I
IF(I(1).NE.'C')GO TO 4
IF(I(2).NE.'O')GO TO 4
C FOR X!Z% ET DIRECTORY
5 READ(1,10)I
IF(I(3).NE.';')GO TO 5
GO TO 1
4 DO 3 K=80,1,-1
N=I(K)
3 IF(N.EQ.'/'.OR.N.EQ.';')RETURN
CCC IF(I(1).NE.'@')GO TO 1
C START LINE WITH '@' FOR LITERAL REPRODUCTION.
DO 6 K=80,1,-1
6 IF(I(K).NE.' ')GO TO 7
7 WRITE(21,10)(I(L),L=1,K)
TYPE 11,(I(L),L=1,K)
GO TO 1
C IGNORES BLANK LINES OR UNTERMINATED LINES.
2 STOP
END
SUBROUTINE WRITER
COMMON /LST/J1,J2,J3,J4,J5,NTS(1000),IRH(700),IM(500)
1 ,IB(500),ISL(500)
2 CALL OUTIT(NTS,J1)
CALL OUTIT(IRH,J2)
CALL OUTIT(IM,J3)
CALL OUTX(IB,J4)
CALL OUTX(ISL,J5)
END
SUBROUTINE OUTX(IX,J)
DIMENSION IX(1)
COMMON /LST/J1,J2,J3,J4,J5,NTS(1000),IRH(700),IM(500)
K=1
IF(J.LE.1)GO TO 4
IF(IX(2).NE.'B')GO TO 3
C NEXT FOR AUTO-BEAMS (E.G. 2B; 3B1; ETC.)
CALL OUTIT(IX,J)
RETURN
3 DO 6 L=1,J,2
MM=IX(L)
IF(MM.GE.100)GO TO 5
IF(MM.GE.0)GO TO 6
IX(L)=-MM
CHANGE -M,N TO M,-N
IX(L+1)=IX(L+1)+200
GO TO 6
5 IX(L)=MM-100
CHANGES M+100,N TO M,N+100
IX(L+1)=IX(L+1)+100
6 CONTINUE
JJ=' '
NN=1
DO 1 L=1,J
LL=IX(L)
CALL I2A(LL,MM,M,N)
IF(LL.LT.96)GO TO 7
IF(LL.GE.99)GO TO 7
IF(LL.EQ.98)GO TO 8
CC MX=NTS(K-4)
MY=NTS(K-3)
MZ=NTS(K-2)
NTS(K-4)='-'
IF(LL.EQ.96)GO TO 10
N='9'
GO TO 11
10 M='0'
N=MZ
11 NTS(K-3)=M
NTS(K-2)=N
M=MY
N=MZ
GO TO 7
C THESE ARE FOR SLURS BEFORE AND AFTER STAFF LIMIT
8 N='0'
M='0'
7 NTS(K)=MM
NTS(K+1)=M
NTS(K+2)=N
NTS(K+3)=JJ
JJ='/'
IF(NN)JJ=' '
NN=-NN
1 K=K+4
K=K-1
4 NTS(K)=';'
DO 2 L=K+1,K+79
2 NTS(L)=' '
CALL OUTIT(NTS,K)
END
FUNCTION ICHAR(J)
COMMON /INP/JN,I(1)
J=J+1
ICHAR=I(J)
END